VERSION 5.00
Begin VB.UserControl ScrollBar 
   AutoRedraw      =   -1  'True
   ClientHeight    =   1530
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   1215
   ScaleHeight     =   102
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   81
   ToolboxBitmap   =   "ScrollBar.ctx":0000
   Begin VB.ComboBox cb 
      Height          =   315
      ItemData        =   "ScrollBar.ctx":0312
      Left            =   1920
      List            =   "ScrollBar.ctx":031F
      Style           =   2  'Dropdown List
      TabIndex        =   1
      Top             =   120
      Width           =   735
   End
   Begin VB.PictureBox pic 
      AutoRedraw      =   -1  'True
      AutoSize        =   -1  'True
      BorderStyle     =   0  'None
      Height          =   720
      Left            =   120
      Picture         =   "ScrollBar.ctx":0333
      ScaleHeight     =   48
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   64
      TabIndex        =   0
      Top             =   120
      Visible         =   0   'False
      Width           =   960
   End
   Begin VB.Timer tmrDey 
      Enabled         =   0   'False
      Interval        =   10
      Left            =   600
      Top             =   960
   End
   Begin VB.Timer tmrOver 
      Enabled         =   0   'False
      Interval        =   3
      Left            =   120
      Top             =   960
   End
End
Attribute VB_Name = "ScrollBar"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Private Type POINTAPI
    X       As Long
    Y       As Long
End Type

Private Type RECT
    Left    As Long
    Top     As Long
    Right   As Long
    Bottom  As Long
End Type

' API Declarations
Private Declare Function SetRect _
                Lib "user32" (lpRect As RECT, _
                              ByVal X1 As Long, _
                              ByVal Y1 As Long, _
                              ByVal X2 As Long, _
                              ByVal Y2 As Long) As Long

Private Declare Function WindowFromPoint _
                Lib "user32" (ByVal xPoint As Long, _
                              ByVal yPoint As Long) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long

Private Declare Function BitBlt _
                Lib "gdi32" (ByVal hDestDC As Long, _
                             ByVal X As Long, _
                             ByVal Y As Long, _
                             ByVal nWidth As Long, _
                             ByVal nHeight As Long, _
                             ByVal hSrcDC As Long, _
                             ByVal xSrc As Long, _
                             ByVal ySrc As Long, _
                             ByVal dwRop As Long) As Long

Private Declare Function StretchBlt _
                Lib "gdi32" (ByVal hDc As Long, _
                             ByVal X As Long, _
                             ByVal Y As Long, _
                             ByVal nWidth As Long, _
                             ByVal nHeight As Long, _
                             ByVal hSrcDC As Long, _
                             ByVal xSrc As Long, _
                             ByVal ySrc As Long, _
                             ByVal nSrcWidth As Long, _
                             ByVal nSrcHeight As Long, _
                             ByVal dwRop As Long) As Long
    
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDc As Long) As Long
Private Declare Function CreateCompatibleBitmap _
                Lib "gdi32" (ByVal hDc As Long, _
                             ByVal nWidth As Long, _
                             ByVal nHeight As Long) As Long

Private Declare Function DeleteDC Lib "gdi32" (ByVal hDc As Long) As Long
Private Declare Function SelectObject _
                Lib "gdi32" (ByVal hDc As Long, _
                             ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long

Private Enum ENUMPCSSBTAGSTATE
    [pstNormal]
    [pstUpOver]
    [pstUpDown]
    [pstDownOver]
    [pstDownDown]
    [pstMoveBar]
End Enum

Dim m_rDown    As RECT
Dim m_rBar     As RECT

Dim m_eState   As ENUMPCSSBTAGSTATE

Dim m_Max      As Double
Dim m_Value    As Double
Dim m_Speed    As Double
Dim m_Subtract As Single

Dim mDC        As Long

Event Scroll()
Event MouseLeave()

' Draw picasa scrollbar
Private Sub DrawScrollbar()
    Dim lW&, lh&, mbT&, mbH&
    
    UserControl.Cls
    
    lW = UserControl.ScaleWidth
    lh = UserControl.ScaleHeight
    
    ' Set rect to draw
    SetRect m_rDown, 0, lh - 24, 0, 24                                    ' Down
    
    mbH = (lh - 48) / m_Max

    If mbH < 50 Then mbH = 50
    mbT = 24 + (m_Value / m_Max * (lh - 48 - mbH))

    If mbT < 24 Then mbT = 24
    If mbT > lh - 24 - mbH Then mbT = lh - 24 - mbH
    SetRect m_rBar, 0, mbT, 16, mbH

    ' Draw background
    StretchBlt hDc, 0, 0, 16, lh, mDC, 48, 24, 16, 24, vbSrcCopy
    
    ' Draw button
    BitBlt hDc, 0, 0, 16, 24, mDC, 0, 0, vbSrcCopy                        ' Up
    BitBlt hDc, 0, m_rDown.Top, 16, 24, mDC, 0, 24, vbSrcCopy             ' Down
    
    Select Case m_eState

        Case 1: ' Up-Over
            BitBlt hDc, 0, 0, 16, 24, mDC, 16, 0, vbSrcCopy

        Case 2: ' Up-Down
            BitBlt hDc, 0, 0, 16, 24, mDC, 32, 0, vbSrcCopy

        Case 3: ' Down-Over
            BitBlt hDc, 0, m_rDown.Top, 16, 24, mDC, 16, 24, vbSrcCopy

        Case 4: ' Down-Down
            BitBlt hDc, 0, m_rDown.Top, 16, 24, mDC, 32, 24, vbSrcCopy
    End Select
    
    ' Draw bar
    StretchBlt hDc, 0, mbT, 16, mbH, mDC, 48, 2, 16, 2, vbSrcCopy         ' Middle
    BitBlt hDc, 0, mbT, 16, 2, mDC, 48, 0, vbSrcCopy                      ' Top
    BitBlt hDc, 0, mbT + mbH - 2, 16, 2, mDC, 48, 22, vbSrcCopy           ' Bottom
    
    UserControl.Refresh
End Sub

' Check mouse over state
Private Function isMouseOver() As Boolean
    On Error GoTo NoMouse:
    Dim mPoint As POINTAPI
    GetCursorPos mPoint
    isMouseOver = WindowFromPoint(mPoint.X, mPoint.Y) = hWnd
NoMouse:                 End Function

Private Sub cb_Change()
    cb_Click
End Sub

Private Sub cb_Click()

    If cb.ListIndex = 0 Then Value = Value - m_Max * (m_Speed / 10)
    If cb.ListIndex = 2 Then Value = Value + m_Max * (m_Speed / 10)
    cb.ListIndex = 1
End Sub

Private Sub tmrDey_Timer()
    Static N%

    If m_eState <> pstUpDown And m_eState <> pstDownDown Then
        N = 0
        tmrDey.Enabled = False
    End If

    If N < 1000 Then N = N + 50
    If N >= 1000 Then
        If m_eState = pstUpDown Then Value = Value - m_Max * (m_Speed / 10)
        If m_eState = pstDownDown Then Value = Value + m_Max * (m_Speed / 10)
    End If
End Sub

' Mouse leave state
Private Sub tmrOver_Timer()

    If Not isMouseOver And m_eState <> pstMoveBar Then
        m_eState = pstNormal
        DrawScrollbar
        tmrOver.Enabled = False
    End If
End Sub

Private Sub UserControl_InitProperties()
    On Error Resume Next
    CreateScrollbar
    Enabled = True
    Max = 100
    Value = 0
    Speed = 1
    cb.ListIndex = 1
End Sub

Private Sub UserControl_MouseDown(Button As Integer, _
                                  Shift As Integer, _
                                  X As Single, _
                                  Y As Single)

    ' Value to subtract
    If Button = vbLeftButton Then
        If (X >= 0 And X <= 16) Then
            If (Y >= m_rBar.Top And Y <= m_rBar.Top + m_rBar.Bottom) Then
                m_eState = pstMoveBar
                m_Subtract = Y - m_rBar.Top
            End If
        End If
    End If
    Call UserControl_MouseMove(Button, Shift, X, Y)
End Sub

Private Sub UserControl_MouseMove(Button As Integer, _
                                  Shift As Integer, _
                                  X As Single, _
                                  Y As Single)
    tmrOver.Enabled = True
    
    If m_eState <> pstMoveBar Then

        ' Up/Down button state
        If (X >= 0 And X <= 16) Then
            If (Y >= 0 And Y <= 24) Then
                m_eState = IIf(Button = vbLeftButton, pstUpDown, pstUpOver)
            ElseIf (Y >= m_rDown.Top And Y <= m_rDown.Top + 24) Then
                m_eState = IIf(Button = vbLeftButton, pstDownDown, pstDownOver)
            Else
                m_eState = pstNormal
            End If
        End If
    
        If Not isMouseOver Then m_eState = pstNormal
        
    Else
        ' Move scrollbar
        Dim valTmp As Double
        valTmp = FormatNumber((Y - (24 + m_Subtract)) / (UserControl.ScaleHeight - 48 - m_rBar.Bottom) * m_Max, 5)

        If valTmp < 0 Then valTmp = 0
        If valTmp > m_Max Then valTmp = m_Max
        Value = valTmp
    End If
    
    If tmrDey.Enabled = False Then
        If m_eState = pstUpDown Then Value = Value - m_Max * (m_Speed / 10)
        If m_eState = pstDownDown Then Value = Value + m_Max * (m_Speed / 10)
        tmrDey.Enabled = True
    End If
    
    If isMouseOver Then cb.SetFocus
    
    DrawScrollbar
End Sub

Private Sub UserControl_MouseUp(Button As Integer, _
                                Shift As Integer, _
                                X As Single, _
                                Y As Single)
    ' Restore normal state
    m_eState = pstNormal
    Call UserControl_MouseMove(vbRightButton, Shift, X, Y)
End Sub

' Limited control size
Private Sub UserControl_Resize()
    On Error Resume Next
    UserControl.Width = 240
    DrawScrollbar
End Sub

Private Function hDc&()
    hDc = UserControl.hDc
End Function

Private Function hWnd&()
    hWnd = UserControl.hWnd
End Function

' Enabled property
Public Property Get Enabled() As Boolean
    Enabled = UserControl.Enabled
End Property

Public Property Let Enabled(ByVal New_Value As Boolean)
    UserControl.Enabled = New_Value
    PropertyChanged "Enabled"
End Property

' Max property
Public Property Get Max() As Double
    Max = m_Max
End Property

Public Property Let Max(ByVal New_Max As Double)

    If New_Max < 2 Then New_Max = 2
    If Value > New_Max Then Value = New_Max
    m_Max = New_Max
    DrawScrollbar
    PropertyChanged "Max"
End Property

' Value property
Public Property Get Value() As Double
    Value = m_Value
End Property

Public Property Let Value(ByVal New_Value As Double)

    If New_Value < 0 Then New_Value = 0
    If New_Value > m_Max Then New_Value = m_Max
    m_Value = New_Value
    RaiseEvent Scroll
    DrawScrollbar
    PropertyChanged "Value"
End Property

' Speed property
Public Property Get Speed() As Double
    Speed = m_Speed
End Property

Public Property Let Speed(ByVal New_Speed As Double)

    If New_Speed <= 0 Then New_Speed = 0.1
    If New_Speed > 5 Then New_Speed = 5
    m_Speed = New_Speed
    RaiseEvent Scroll
    DrawScrollbar
    PropertyChanged "Speed"
End Property

Private Sub UserControl_Show()
    CreateScrollbar
    DrawScrollbar
    cb.ListIndex = 1
End Sub

Private Sub UserControl_Terminate()
    On Error Resume Next
    DeleteDC mDC
End Sub

Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
    On Error Resume Next
    PropBag.WriteProperty "Enabled", Enabled, "True"
    PropBag.WriteProperty "Max", m_Max, 0
    PropBag.WriteProperty "Value", m_Value, 0
    PropBag.WriteProperty "Speed", m_Speed, 0
End Sub

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
    On Error Resume Next
    Enabled = PropBag.ReadProperty("Enabled", "True")
    m_Max = PropBag.ReadProperty("Max", 0)
    m_Value = PropBag.ReadProperty("Value", 0)
    m_Speed = PropBag.ReadProperty("Speed", 0)
End Sub

Private Sub CreateScrollbar()
    On Error Resume Next
    Dim mBitmap
    mDC = CreateCompatibleDC(UserControl.hDc)
    mBitmap = CreateCompatibleBitmap(UserControl.hDc, 64, 48)
    SelectObject mDC, mBitmap
    BitBlt mDC, 0, 0, 64, 48, pic.hDc, 0, 0, vbSrcCopy
    DeleteObject mBitmap
End Sub
